home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / HUGS1 / hs / Cse / csexpr next >
Text File  |  1995-02-14  |  11KB  |  384 lines
  1. -- This is a program to illustrate a simple form of common subexpression
  2. -- elimination ... essentially turning trees into DAGs.  Uses two state
  3. -- monads (more precisely, same monad but different state types).
  4. -- This program doesn't use constructor classes, although it could
  5. -- obviously be modified to fit into that framework.
  6. --
  7. -- This programs should be loaded after `stateMonad':  For example:
  8. --  ? :l stateMonad.gs csexpr.gs
  9. --  ? test
  10. --
  11. -- The output for this `test' is included at the end of the file.
  12. --
  13. -- Mark P. Jones, 1992
  14. --
  15.  
  16. -- Data type definitions: ----------------------------------------------------
  17.  
  18. data GenTree a  = Node a [GenTree a]
  19. type LabGraph a = [ (Label, a, [Label]) ]
  20. type Label      = Int
  21.  
  22. -- Add distinct (integer) labels to each node of a tree: ---------------------
  23.  
  24. labelTree   :: GenTree a -> GenTree (Label,a)
  25. labelTree t  = label t `startingWith` 0
  26.                where label (Node x xs) = incr           `bind` \n  ->
  27.                                          mmapl label xs `bind` \ts ->
  28.                                          return (Node (n,x) ts)
  29.  
  30. -- Convert tree after labelling each node to a labelled graph: ---------------
  31.  
  32. ltGraph                :: GenTree (Label,a) -> LabGraph a
  33. ltGraph (Node (n,x) xs) = (n, x, map labelOf xs) : concat (map ltGraph xs)
  34.                           where labelOf (Node (n,x) xs) = n
  35.  
  36. -- Build tree from labelled graph: -------------------------------------------
  37.  
  38. unGraph              :: LabGraph a -> GenTree a
  39. unGraph ((n,x,cs):ts) = Node x (map (unGraph . find) cs)
  40.                         where find c = dropWhile (\(d,_,_) -> c/=d) ts
  41.  
  42.  
  43. -- Build tree but avoid duplicating shared parts: ----------------------------
  44.  
  45. unGraph'     :: LabGraph String -> GenTree (Int,String)
  46. unGraph' lg   = ung lg `startingWith` []
  47.  where ung ((n,x,cs):ts) = mif (visited n)
  48.                                  (return (Node (n,"<>") []))
  49.                                  (mmapl (ung . find) cs `bind` \ts ->
  50.                                   return (Node (n,x) ts))
  51.                            where find c = dropWhile (\(d,_,_) -> c/=d) ts
  52.  
  53. visited      :: Label -> SM [Label] Bool
  54. visited n     = fetch                               `bind` \us ->
  55.                 if n `elem` us then return True
  56.                                else set (n:us)      `bind` \_ -> 
  57.                                     return False
  58.  
  59. -- Find (and eliminate) repeated subtrees in a labelled graph: ---------------
  60. -- Described as a transformation on labelled graphs:  During the calculation
  61. -- we use a pair (r,lg) :: (Label->Label, LabGraph a) where lg contains the
  62. -- simplified portion of the graph calculated so far and r is a renaming (or
  63. -- replacement?) which maps node labels in the original graph to the approp.
  64. -- labels in the new graph.
  65.  
  66. findCommon :: Eq a => LabGraph a -> LabGraph a
  67. findCommon  = snd . foldr sim (id,[])
  68.  where sim (n,s,cs) (r,lg)
  69.            | null ms   = (r, [(n,s,rcs)]++lg)
  70.            | otherwise = ((n +-> head ms) r, lg)
  71.                          where ms  = [m | (m,s',cs')<-lg, s==s', cs'==rcs]
  72.                                rcs = map r cs
  73.  
  74. infix +->      -- overide function at single point
  75. (+->)          :: Eq a => a -> b -> (a -> b) -> (a -> b)
  76. (x +-> fx) f y  = if x==y then fx else f y
  77.  
  78. -- Common subexpression elimination: -----------------------------------------
  79.  
  80. cse :: Eq a => GenTree a -> LabGraph a
  81. cse  = findCommon . ltGraph . labelTree
  82.  
  83. -- Pretty printers: ----------------------------------------------------------
  84.  
  85. instance Text a => Text (GenTree a) where
  86.     showsPrec d (Node x ts)
  87.         | null ts   = shows x
  88.         | otherwise = showChar '(' . shows x
  89.                                    . showChar ' '
  90.                                    . (foldr1 (\x y -> x . showChar ' ' . y)
  91.                                              (map shows ts))
  92.                                    . showChar ')'
  93.  
  94. copy            :: Int -> a -> [a]
  95. copy  n x        = take n (repeat x)
  96. space n          = copy n ' '
  97.  
  98. drawTree        :: GenTree String -> String
  99. drawTree         = unlines . draw
  100. draw (Node x ts) = grp (s1 ++ pad width x ++ "]") (space (width+3)) (stLoop ts)
  101.  where stLoop []     = [""]
  102.        stLoop [t]    = grp s2 "  " (draw t)
  103.        stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
  104.  
  105.        rsLoop [t]    = grp s5 "  " (draw t)
  106.        rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
  107.  
  108.        grp fst rst   = zipWith (++) (fst:repeat rst)
  109.  
  110.        -- Define the strings used to print tree diagrams:
  111.        [s1,s2,s3,s4,s5,s6] | pcGraphics = ["\196[", "\196\196", "\196\194",
  112.                                            " \179", " \192",    " \195"]
  113.                            | otherwise  = ["-[",    "--",       "-+",
  114.                                            " |",    " `",       " +"]
  115.  
  116.        pad n x    = take n (x ++ repeat ' ')
  117.        width      = 4
  118.        pcGraphics = False
  119.  
  120. showGraph   :: Text a => LabGraph a -> String
  121. showGraph [] = "[]\n"
  122. showGraph xs = "[" ++ loop (map show xs)
  123.                where loop [x]    = x ++ "]\n"
  124.                      loop (x:xs) = x ++ ",\n " ++ loop xs
  125.  
  126. -- Examples: -----------------------------------------------------------------
  127.  
  128. plus x y = Node "+" [x,y]
  129. mult x y = Node "*" [x,y]
  130. prod xs  = Node "X" xs
  131. zero     = Node "0" []
  132. a        = Node "a" []
  133. b        = Node "b" []
  134. c        = Node "c" []
  135. d        = Node "d" []
  136.  
  137. examples = [example0, example1, example2, example3, example4, example5]
  138. example0 = a
  139. example1 = plus a a
  140. example2 = plus (mult a b) (mult a b)
  141. example3 = plus (mult (plus a b) c) (plus a b)
  142. example4 = prod (scanl plus zero [a,b,c,d])
  143. example5 = prod (scanr plus zero [a,b,c,d])
  144.  
  145. test  = appendChan "stdout" -- writeFile "csoutput"
  146.          (unlines (map (\t -> let c = cse t
  147.                               in  copy 78 '-'            ++
  148.                                   "\nExpression:\n"      ++ show t      ++
  149.                                   "\n\nTree:\n"          ++ drawTree t  ++
  150.                                   "\nLabelled graph:\n"  ++ showGraph c ++
  151.                                   "\nSimplified tree:\n" ++ showCse c)
  152.                        examples))
  153.          exit
  154.          done
  155.         where
  156.          showCse                  = drawTree
  157.                                     . mapGenTree (\(n,s) -> show n++":"++s)
  158.                                     . unGraph'
  159.          mapGenTree f (Node x ts) = Node (f x) (map (mapGenTree f) ts)
  160.  
  161. {-----------------------------------------------------------------------------
  162. Expression:
  163. a
  164.  
  165. Tree:
  166. -[a   ]
  167.  
  168. Labelled graph:
  169. [(0,"a",[])]
  170.  
  171. Simplified tree:
  172. -[0:a ]
  173.  
  174. ------------------------------------------------------------------------------
  175. Expression:
  176. (+ a a)
  177.  
  178. Tree:
  179. -[+   ]-+-[a   ]
  180.         |
  181.         `-[a   ]
  182.  
  183. Labelled graph:
  184. [(0,"+",[2, 2]),
  185.  (2,"a",[])]
  186.  
  187. Simplified tree:
  188. -[0:+ ]-+-[2:a ]
  189.         |
  190.         `-[2:<>]
  191.  
  192. ------------------------------------------------------------------------------
  193. Expression:
  194. (+ (* a b) (* a b))
  195.  
  196. Tree:
  197. -[+   ]-+-[*   ]-+-[a   ]
  198.         |        |
  199.         |        `-[b   ]
  200.         |
  201.         `-[*   ]-+-[a   ]
  202.                  |
  203.                  `-[b   ]
  204.  
  205. Labelled graph:
  206. [(0,"+",[4, 4]),
  207.  (4,"*",[5, 6]),
  208.  (5,"a",[]),
  209.  (6,"b",[])]
  210.  
  211. Simplified tree:
  212. -[0:+ ]-+-[4:* ]-+-[5:a ]
  213.         |        |
  214.         |        `-[6:b ]
  215.         |
  216.         `-[4:<>]
  217.  
  218. ------------------------------------------------------------------------------
  219. Expression:
  220. (+ (* (+ a b) c) (+ a b))
  221.  
  222. Tree:
  223. -[+   ]-+-[*   ]-+-[+   ]-+-[a   ]
  224.         |        |        |
  225.         |        |        `-[b   ]
  226.         |        |
  227.         |        `-[c   ]
  228.         |
  229.         `-[+   ]-+-[a   ]
  230.                  |
  231.                  `-[b   ]
  232.  
  233. Labelled graph:
  234. [(0,"+",[1, 6]),
  235.  (1,"*",[6, 5]),
  236.  (5,"c",[]),
  237.  (6,"+",[7, 8]),
  238.  (7,"a",[]),
  239.  (8,"b",[])]
  240.  
  241. Simplified tree:
  242. -[0:+ ]-+-[1:* ]-+-[6:+ ]-+-[7:a ]
  243.         |        |        |
  244.         |        |        `-[8:b ]
  245.         |        |
  246.         |        `-[5:c ]
  247.         |
  248.         `-[6:<>]
  249.  
  250. ------------------------------------------------------------------------------
  251. Expression:
  252. (X 0 (+ 0 a) (+ (+ 0 a) b) (+ (+ (+ 0 a) b) c) (+ (+ (+ (+ 0 a) b) c) d))
  253.  
  254. Tree:
  255. -[X   ]-+-[0   ]
  256.         |
  257.         +-[+   ]-+-[0   ]
  258.         |        |
  259.         |        `-[a   ]
  260.         |
  261.         +-[+   ]-+-[+   ]-+-[0   ]
  262.         |        |        |
  263.         |        |        `-[a   ]
  264.         |        |
  265.         |        `-[b   ]
  266.         |
  267.         +-[+   ]-+-[+   ]-+-[+   ]-+-[0   ]
  268.         |        |        |        |
  269.         |        |        |        `-[a   ]
  270.         |        |        |
  271.         |        |        `-[b   ]
  272.         |        |
  273.         |        `-[c   ]
  274.         |
  275.         `-[+   ]-+-[+   ]-+-[+   ]-+-[+   ]-+-[0   ]
  276.                  |        |        |        |
  277.                  |        |        |        `-[a   ]
  278.                  |        |        |
  279.                  |        |        `-[b   ]
  280.                  |        |
  281.                  |        `-[c   ]
  282.                  |
  283.                  `-[d   ]
  284.  
  285. Labelled graph:
  286. [(0,"X",[21, 20, 19, 18, 17]),
  287.  (17,"+",[18, 25]),
  288.  (18,"+",[19, 24]),
  289.  (19,"+",[20, 23]),
  290.  (20,"+",[21, 22]),
  291.  (21,"0",[]),
  292.  (22,"a",[]),
  293.  (23,"b",[]),
  294.  (24,"c",[]),
  295.  (25,"d",[])]
  296.  
  297. Simplified tree:
  298. -[0:X ]-+-[21:0]
  299.         |
  300.         +-[20:+]-+-[21:<]
  301.         |        |
  302.         |        `-[22:a]
  303.         |
  304.         +-[19:+]-+-[20:<]
  305.         |        |
  306.         |        `-[23:b]
  307.         |
  308.         +-[18:+]-+-[19:<]
  309.         |        |
  310.         |        `-[24:c]
  311.         |
  312.         `-[17:+]-+-[18:<]
  313.                  |
  314.                  `-[25:d]
  315.  
  316.  
  317. ------------------------------------------------------------------------------
  318. Expression:
  319. (X (+ a (+ b (+ c (+ d 0)))) (+ b (+ c (+ d 0))) (+ c (+ d 0)) (+ d 0) 0)
  320.  
  321. Tree:
  322. -[X   ]-+-[+   ]-+-[a   ]
  323.         |        |
  324.         |        `-[+   ]-+-[b   ]
  325.         |                 |
  326.         |                 `-[+   ]-+-[c   ]
  327.         |                          |
  328.         |                          `-[+   ]-+-[d   ]
  329.         |                                   |
  330.         |                                   `-[0   ]
  331.         |
  332.         +-[+   ]-+-[b   ]
  333.         |        |
  334.         |        `-[+   ]-+-[c   ]
  335.         |                 |
  336.         |                 `-[+   ]-+-[d   ]
  337.         |                          |
  338.         |                          `-[0   ]
  339.         |
  340.         +-[+   ]-+-[c   ]
  341.         |        |
  342.         |        `-[+   ]-+-[d   ]
  343.         |                 |
  344.         |                 `-[0   ]
  345.         |
  346.         +-[+   ]-+-[d   ]
  347.         |        |
  348.         |        `-[0   ]
  349.         |
  350.         `-[0   ]
  351.  
  352. Labelled graph:
  353. [(0,"X",[1, 10, 17, 22, 25]),
  354.  (1,"+",[2, 10]),
  355.  (2,"a",[]),
  356.  (10,"+",[11, 17]),
  357.  (11,"b",[]),
  358.  (17,"+",[18, 22]),
  359.  (18,"c",[]),
  360.  (22,"+",[23, 25]),
  361.  (23,"d",[]),
  362.  (25,"0",[])]
  363.  
  364. Simplified tree:
  365. -[0:X ]-+-[1:+ ]-+-[2:a ]
  366.         |        |
  367.         |        `-[10:+]-+-[11:b]
  368.         |                 |
  369.         |                 `-[17:+]-+-[18:c]
  370.         |                          |
  371.         |                          `-[22:+]-+-[23:d]
  372.         |                                   |
  373.         |                                   `-[25:0]
  374.         |
  375.         +-[10:<]
  376.         |
  377.         +-[17:<]
  378.         |
  379.         +-[22:<]
  380.         |
  381.         `-[25:<]
  382.  
  383. -}----------------------------------------------------------------------------
  384.